TITLE PRIM
;ACCUMULATOR DEFINITIONS
P←14
F←15
FF←16

A←1
B←2
C←3
D←4
T←6
R←13
TT←7
NIL←0
INUM0←577777


;LISP FUNCTION CALL UUO'S
OPDEF CALL [34B8]
OPDEF JCALL [35B8]
OPDEF CALLF [36B8]
OPDEF JCALLF [37B8]

EXTERNAL TRUTH,INTERN,CHRCT,FLATSIZE,ATOM,SCAN,SCNVAL
EXTERNAL NILX,STAR,READP1


NILRET:	MOVEI A,NIL
	POPJ P,

TRET:	MOVEI A,TRUTH
	POPJ P,


LOSE:	PUSHJ P,UNWIND
NILXR:	MOVEI A,NILX	;NILX IS *NIL*
	POPJ P,


REDPTR:	0

INTERNAL XXTRY,ATM

ATM:	PUSHJ P,LOOK
	MOVEI A,INUM0+3
	CAIN A,(B)	;IS IT A DELIMITER?
	JRST UNWIND	;YES, LOSE
	JRST TRY2	;NO, IT IS AN ATOM -- ACCEPT IT

XXTRY:	PUSHJ P,LOOK
	CAIE A,(B)
	JRST UNWIND
TRY2:	SOS BKUPTR
	AOS REDPTR
	MOVEM B,@REDPTR
	JRST TRET

INTERNAL ISIT,ISITN
EXTERNAL ACONS
ISITN: SETOM ISFLG#
	JRST .+2
ISIT:	SETZM ISFLG#
	JUMPE A,NILRET	;IT ISN'T
	PUSH P,A	;MAYBE
	PUSHJ P,LOOK
	HLRZ A,B
	HRRZ C,B
	CAIN C,INUM0+0
	JRST ISIT1
	CAIN C,INUM0+1
	JRST ISIT4	;LOSE ON STRINGS
	CAIN C,INUM0+2
	JRST ISIT1	;TAKE NUMBERS
	CAIE C,INUM0+3
	JRST ISIT4 ;LOSE AGAIN
	PUSH P,B
	PUSHJ P,ACONS-7	;H.S. TO ASCII
	PUSHJ P,INTERN
	POP P,B
ISIT1:	POP P,D	;NOW MEMQ IT
	MOVS C,(D)
	CAIN A,(C)
	JRST ISIT2	;IT IS
	HLRZ D,C
	JUMPN D,ISIT1+1
	SKIPN ISFLG
	JRST UNWIND
ISIT3:	SOS BKUPTR
	AOS REDPTR
	MOVEM B,@REDPTR
	POPJ P,0
ISIT4:	POP P,A
	JRST UNWIND
ISIT2:	SKIPE ISFLG
	JRST UNWIND
	JRST ISIT3

LOOK:	SKIPE B,@BKUPTR
	POPJ P,
	PUSH P,A
	PUSHJ P,SCAN
	CAIN A,INUM0
	JRST	[MOVE A,SCNVAL
		PUSHJ P,INTERN
		MOVSS A
		HRRI A,INUM0
		JRST LOOK2]
	HRL A,SCNVAL
LOOK2:	AOS BKUPTR
	MOVEM A,@BKUPTR
	MOVE B,A
	POP P,A
	POPJ P,

INTERNAL SPWDX,CHX
SPWDX:	HRLI A,INUM0
	JRST .+2
CHX:	HRLI A,INUM0+3
	MOVSS A
	PUSHJ P,LOOK
	CAME A,B	;IS BOTH TYPE AND VALUE THE SAME?
	JRST UNWIND	;NO, LOSE
	JRST TRY2	;YES, TAKE IT


INTERNAL STK,PDLSET

STK:	MOVNI A,-INUM0(A)	;THIS SHOULD BE NEGATIVE NUMVAL
	ADD A,REDPTR	;0 IS THE TOP OF THE STACK
	HLRZ A,(A)	;THE SEMANTIC VALUE IS IN THE LEFT HALF
	POPJ P,

;PDLSET INITIALIZES PDLPTR TO POINT TO A LISP ARRAY 

PDLSET:	ADDI B,12
	ADDI A,12	;GET ADDRESSES OF 1ST ARRAY WORDS
	MOVEM A,REDPTR
	MOVEM B,BKUPTR
	SETZM @BKUPTR
	JRST MARK



INTERNAL REDUCE
;REDUCE RESETS TO STACK TO BELOW THE MARK
;A CONTAINS SYNTACTIC VALUE, B CONTAINS SEMANTIC VALUE
REDUCE:	PUSHJ P,UNMARK	;RESET STACK TO BELOW MARK
	CAIN B,NILX	;IS SEMANTIC VALUE *NIL*?
	JRST UNWIND	;YES, UNWIND STACK TO PREVIOUS MARK
	HRL A,B	;NO, CONSTRUCT REDUCTION WORD
	AOS REDPTR
	MOVEM A,@REDPTR		;PUSH IT ONTO REDUCTION STACK
	JRST TRET

UNMARK:	HRRO T,REDMRK#
	POP T,REDMRK	;RESTORE REDMRK TO ITS PREVIOUS VALUE
	HRRZM T,REDPTR	;RESTORE REDPTR TO BELOW REDMRK
	POPJ P,

MARK:	HRRZ T,REDPTR
	PUSH T,REDMRK	;SAVE REDMRK
	HRROM T,REDMRK	;REMEMBER WHERE REDMRK SAVED
	HRRZM T,REDPTR	;UPDATE REDPTR
	JRST NILRET	;PDL OVERFLOW CHECKING HERE?

UNWIND:	HRRO T,REDPTR
	SKIPA TT,BKUPTR#
UNWIN2:	PUSH TT,A
	POP T,A		;GET A WORD FROM REDUCTION PDL
	TLC A,-1
	TLCE A,-1
	JRST UNWIN2	;IF NOT A MARK, TRANSFER IT TO BACKUP PDL
	PUSH T,A	;FOUND A MARK, RESTORE IT
	HRRZM T,REDPTR	;AND UPDATE POINTERS
	HRRZM TT,BKUPTR
	JRST NILRET	;PDL OVERFLOW CHECKING HERE?




ISSTR:	MOVE B,@BKUPTR	;GET TOP OF BACKUP STACK
	CAIE A,(B)	;IS IT THE PROPER TYPE?
	JRST MARK	;NO, PROCEED WITH RULE
	SOS BKUPTR	;YES, TRANSFER IT TO REDUCTION PDL
	AOS REDPTR
	MOVEM B,@REDPTR
	JRST TRET



INTERNAL LRR,NLRR

;LRR--LEFT RECURSIVE RULE
;A CONTAINS NAME OF RULE
;B CONTAINS NON LEFT-RECURSIVE FUNCTION
;C CONTAINS LEFT-RECURSIVE FUNCTION

LRR:	PUSH P,A	;SAVE NAME
	PUSH P,B	;SAVE FUNCTIONS
	PUSH P,C
	PUSHJ P,ISSTR	;IS A REDUCTION ALREADY MADE?
	JUMPN A,LRRXIT	;YES
	CALLF @-1(P)	;NO, EXECUTE NON LEFT-RECURSIVE FUNCTION
	MOVEM A,-1(P)	;SAVE SEMANTIC VALUE
LRRL:	CAIN A,NILX	;IS IT *NIL*?
	JRST LRRRET	;YES
	MOVEM A,-1(P)	;NO, SAVE SEMANTIC VALUE
	PUSHJ P,UNMARK	;RESET STACK TO MARK
	PUSHJ P,MARK
	HRRZ A,-1(P)	;GET SEMANTIC VALUE
	CALLF 1,@(P)	;EXECUTE LEFT-RECURSIVE FUNCTION
	JRST LRRL	;CONTINUE UNTIL FAILURE

LRRRET:	MOVE B,-1(P)	;GET FINAL SEMANTIC VALUE
	MOVE A,-2(P)	;GET NAME OF RULE(SYNTACTIC VALUE)
	PUSHJ P,REDUCE	;PERFORM THE REDUCTION

LRRXIT:	SUB P,[XWD 3,3]	;RESYNC THE STACK
	POPJ P,

;NLRR---NON LEFT-RECURSIVE RULE
;A CONTAINS NAME OF RULE
;B CONTAINS FUNCTION

NLRR:	PUSH P,A	;SAVE NAME
	PUSH P,B	;SAVE FUNCTION
	PUSHJ P,ISSTR	;IS THE REDUCTION ALREADY MADE?
	JUMPN A,NLRXIT	;YES
	POP P,A	;NO, GET FUNCTION
	CALLF (A)	;CALL FUNCTION
	POP P,B	;GET SYNTACTIC VALUE
	EXCH A,B
	JRST REDUCE	;PERFORM THE REDUCTION

NLRXIT:	SUB P,[XWD 2,2]	;RESYNC STACK
	POPJ P,




INTERNAL PPOS,LOC,FLATC
EXTERNAL TYO,CHRCT,TERPRI,CHCT,LINL

PPOS:	SUBI A,INUM0
	JUMPE A,TERPRI
	MOVEI C,(A)
	MOVE A,LINL
	SUB A,CHCT
	CAMGE C,A
	PUSHJ P,TERPRI
	JRST PPOS2

PPOS22:	MOVEI A,11
	PUSHJ P,TYO
PPOS2:	MOVE B,LINL
	SUB B,CHCT
	CAIL C,8(B)
	JRST PPOS22
	SUB C,B
	MOVEI A,40
	JRST .+2
	PUSHJ P,TYO
	SOJGE C,.-1
	POPJ P,

LOC:	MOVE A,LINL
	SUB A,CHCT
	ADDI A,INUM0
	POPJ P,

FLATC:	HRROI R,FLATSIZE+5
	HLLZS FLATSIZE+3
	JRST FLATSIZE+2



INTERNAL OUTRULE,MATCH

PDLPTR←←REDPTR
OUTRULE:	MOVE T,PDLPTR
	MOVNI A,-INUM0(A)	;SHOULD BE NEGATIVE NUMVAL
	ADDI A,(T)
	PUSH P,A
	PUSH T,(A)
	PUSH T,PDLMARK#
	MOVEM T,PDLMARK
	MOVEM T,PDLPTR
	CALLF (B)
	MOVE T,PDLMARK
	POP T,PDLMARK
	POP T,B
	POP P,B	;SHOULD BE PTR TO X.
	MOVEM T,PDLPTR
	JUMPN A,OR1
	MOVE T,PDLMARK
	MOVEM T,PDLPTR
	POPJ P,

OR1:	HRLZM A,(B)
	POPJ P,


MATCH:	MOVE T,PDLMARK
	MOVE B,A
	HLRZ A,-1(T)
	MOVEM P,PSAV#
	PUSHJ P,MAT
	MOVEM T,PDLPTR
	JRST TRET

MAT:	CAIN B,STAR
	JRST MAT1
	PUSH P,A
	PUSH P,B
	CALL 1,ATOM
	JUMPN A,MAT2
	MOVE A,(P)
	CALL 1,ATOM
	JUMPN A,MAT2
	HLRZ A,@-1(P)
	HLRZ B,@(P)
	PUSHJ P,MAT
	HRRZ A,@-1(P)
	HRRZ B,@(P)
	SUB P,[XWD 2,2]
	JRST MAT

MAT1:	HRLZS A
	PUSH T,A
	POPJ P,

MAT2:	POP P,B
	POP P,A
	CAMN A,B
	POPJ P,

MAT3:	MOVE P,PSAV
	JRST NILRET



	END